home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / SEARCH.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-10-28  |  28.0 KB  |  1,014 lines
  1. ;* SEARCH.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*    String searching capabilities (interpreter support)        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21. IDEAL
  22. %PAGESIZE    60, 132
  23. MODEL   medium
  24. LOCALS    @@
  25.  
  26.     INCLUDE    "scheme.ash"
  27.      INCLUDE "interprt.ash"
  28.  
  29. CODESEG
  30. ;************************************************************************
  31. ;*              Substring-Find-Next-String            *
  32. ;************************************************************************
  33. PROC C    str_srch_str USES si di, @@string, @@start, @@end, @@match, @@direction, @@case_s
  34.      LOCAL    @@stradr, @@length
  35.  
  36.      cld                ; for now, assume forward
  37.      mov    bx, [@@string]
  38.      mov    di, [(REG bx).page]
  39.      cmp    [ptype+di], STRTYPE    ; is source string a string?
  40.      je    @@stringok
  41. @@toerror:
  42.      jmp    @@error
  43. @@stringok:
  44.      ldpage    es, di
  45.      mov    di, [(REG bx).disp]
  46.      sstrlen    ax, <es:di>
  47.      mov    [@@length], ax
  48.      lea    di, [(STRDEF di).buffer]
  49.      mov    [@@stradr], di
  50.      mov    bx, [@@start]
  51.      call    getnum
  52.      jc    @@toerror
  53.     add    di, ax
  54.     mov    cx, ax
  55.      mov    bx, [@@end]
  56.      call    getnum
  57.      jc    @@toerror
  58.      cmp    ax, [@@length]         ; test ending offset against string length
  59.      ja    @@toerror
  60.     sub    ax, cx             ; ax = end - start
  61.      jb    @@toerror
  62.      mov    bx, [@@match]
  63.      mov    si, [(REG bx).page]
  64.      cmp    [ptype+si], STRTYPE    ; this is a string, isn't it?
  65.      jne    @@toerror
  66.  
  67.     push    ds es
  68.      ldpage    es, si
  69.      mov    si, [(REG bx).disp]
  70.     sstrlen    dx, <es:si>
  71.      lea    si, [(STRDEF si).buffer]
  72.     sub    dx, 1            ; dx = strlen(match) - 1
  73.     jnb    @@not_empty
  74.     pop    es
  75.     xor    si, si               ; if empty string, already found
  76.     jmp    @@found
  77. @@not_empty:
  78.     mov    [@@length], dx
  79.     mov    cx, ax
  80.     sub    cx, dx            ; cx = number of tries to do
  81.     jnbe    @@search
  82.     pop    es
  83.     jmp    @@notfound
  84.  
  85. @@search:
  86.     cmp    [@@direction], 0    ; if backward...
  87.     jz    @@fwd
  88.     add    di, ax            ; start from end of strings
  89.     add    si, dx
  90.     std
  91. @@fwd:
  92.     push    es
  93.     pop    ds es ;-------------------------------- DS changed ! \\\
  94.     lodsb                ; read "1st" char of "match"
  95.     cmp    [@@case_s], 0
  96.     jz    @@insensitive
  97.  
  98. @@sensitive:
  99.     jcxz    @@notfound        
  100.     repnz    scasb            ; locate first char of match in str
  101.     jnz    @@notfound
  102.     or    dx, dx            ; single-char target ?
  103.     jz    @@locate_ofs
  104.     push    cx si di
  105.     mov    cx, dx            ; verify other chars
  106.     repz    cmpsb
  107.     pop    di si cx
  108.     jnz    @@sensitive
  109.  
  110. @@locate_ofs:
  111.     mov    si, di
  112.     scasb                ; one step forward -> one step back
  113.     sub    di, si
  114.     jnb    @@forw
  115.     sub    si, dx
  116. @@forw:
  117.     sub    si, di
  118.     sub    si, [@@stradr]
  119. @@found:
  120.     pop    ds
  121.      mov    bx, [@@string]         ; load address of destination register
  122.      call    retnum
  123.      jmp    @@done
  124. @@notfound:
  125.     pop    ds
  126.      xor    ax, ax             ; store nil in the
  127.      mov    bx, [@@string]         ;  destination register
  128.      mov    [(REG bx).bpage], al
  129.      mov    [(REG bx).disp], ax
  130. @@done:
  131.      xor    ax, ax
  132. @@return:
  133.      ret
  134.  
  135. @@insensitive:
  136.     lea    bx, [locases]
  137.     xlat    [ss:bx]
  138.     mov    ah, al
  139. @@loop_ci:
  140.     jcxz    @@notfound        
  141. @@scan_ci:                   ; locate first char of match in str
  142.     mov    al, [es:di]
  143.     scasb    ; di += (if DF -1 1)
  144.     xlat    [ss:bx]
  145.     cmp    al, ah
  146.     loopnz    @@scan_ci    
  147.     jnz    @@notfound
  148.     or    dx, dx            ; single-char target ?
  149.     jz    @@locate_ofs
  150.     push    ax cx si di
  151.     mov    cx, dx            ; verify other chars
  152. @@comp_ci:
  153.     lodsb
  154.     xlat    [ss:bx]
  155.     mov    ah, al
  156.     mov    al, [es:di]
  157.     scasb    ; di += (if DF -1 1)
  158.     xlat    [ss:bx]
  159.     cmp    al, ah
  160.     loopz    @@comp_ci
  161.     pop    di si cx ax
  162.     jnz    @@loop_ci
  163.     jmp    @@locate_ofs
  164.  
  165. @@error:
  166.      cmp    [@@direction], 0    ; search forward or backward?
  167.      jnz    @@backerror
  168.      lea    ax, [@@msgfwd]
  169. DATASEG
  170. @@msgfwd DB    "SUBSTRING-FIND-NEXT-STRING", 0
  171. CODESEG
  172.      jmp    @@allerrors
  173.  
  174. @@backerror:
  175.      lea    ax, [@@msgprv]
  176. DATASEG
  177. @@msgprv DB    "SUBSTRING-FIND-PREVIOUS-STRING", 0
  178. CODESEG
  179.  
  180. @@allerrors:
  181.      mov    bx, 4             ; load VM argument count
  182.      call    set_src_error C, ax, bx, [@@string], [@@start], [@@end], [@@match]
  183.      mov    ax, -1             ; load "invalid operand" flag
  184.      jmp    @@return
  185. ENDP    str_srch_str
  186.     
  187. ;************************************************************************
  188. ;*              Substring-Find-Next-Char-in-Set            *
  189. ;************************************************************************
  190. PROC C    srch_str USES si di, @@string, @@start, @@end, @@charset, @@direction
  191.      LOCAL    @@stradr:dword, @@length, @@endofs, @@startofs
  192.  
  193.      cld                ; for now, assume forward
  194.      mov    cx, [@@direction]    ; set search direction
  195.      mov    bx, [@@string]
  196.      mov    si, [(REG bx).page]
  197.      cmp    [ptype+si], STRTYPE    ; is source string a string?
  198.      je    @@stringok
  199. @@toerror:
  200.      jmp    @@error
  201. @@stringok:
  202.      ldpage    es, si
  203.      mov    si, [(REG bx).disp]
  204.      sstrlen    ax, <es:si>
  205.      mov    [@@length], ax
  206.      lea    si, [(STRDEF si).buffer]
  207.      mov    [WORD LOW @@stradr], si
  208.      mov    [WORD HIGH @@stradr], es
  209.      mov    bx, [@@start]
  210.      call    getnum
  211.      jc    @@toerror
  212.      mov    [@@startofs], ax
  213.      mov    bx, [@@end]
  214.      call    getnum
  215.      jc    @@toerror
  216.      cmp    [@@startofs], ax    ; is starting offset greater than ending?
  217.      ja    @@toerror
  218.      cmp    ax, [@@length]         ; test ending offset against string length
  219.      ja    @@toerror
  220.      mov    [@@endofs], ax
  221.      mov    bx, [@@charset]
  222.      mov    di, [(REG bx).page]
  223.      cmp    [ptype+di], STRTYPE    ; this is a string, isn't it?
  224.      jne    @@char
  225.      ldpage    es, di
  226.      mov    di, [(REG bx).disp]
  227.     sstrlen    dx, <es:di>
  228.      lea    di, [(STRDEF di).buffer]
  229.      jmp    @@strset
  230. @@char:
  231.      cmp    di, SPECCHAR*2         ; is charset argument a single character?
  232.      je    @@singlechar
  233.      jmp    @@toerror
  234.  
  235. @@singlechar:
  236.      mov    al, [byte (REG bx).disp]
  237.      les    di, [@@stradr]
  238.      mov    dx, cx             ; save direction indicator in dx
  239.      mov    cx, [@@endofs]         ; compute length of search string
  240.      sub    cx, [@@startofs]
  241.      je    @@charnotfound         ; if search length is zero, return 'nil
  242.      or    dx, dx
  243.      jnz    @@backchar
  244.      add    di, [@@startofs]     ; compute address of start of substring
  245.      repne    scasb            ; search for single character
  246.      jne    @@charnotfound
  247.      dec    di             ; fix up ending index
  248.      jmp    @@skip
  249. @@backchar:
  250.      add    di, [@@endofs]         ; compute address of end of substring
  251.      dec    di
  252.      std                ; set search direction to be backwards
  253.     repne    scasb
  254.      cld
  255.      jne    @@charnotfound
  256.      inc    di             ; fix up ending index
  257. @@skip:
  258.      mov    si, di             ; copy character address to si
  259.      sub    si, [WORD LOW @@stradr]    ;  and compute found character's address
  260.      jmp    @@found
  261.  
  262. @@strset:
  263.      push    ds             ; save the data segment address
  264.      or    cx, cx             ; in which direction are we to search?
  265.      jz    @@forwardstr
  266.  
  267. ;Register Usage in Innermost Loop:
  268. ;    ds:si - pointer to next character in source string
  269. ;    es:di - pointer to charset string
  270. ;    al    - search character
  271. ;    bx    - ending offset (source string)
  272. ;    cx    - length of charset string
  273. ;    dx    - length of charset string (used to refresh cx)
  274.  
  275.     mov    bx, [WORD LOW @@stradr] ; compute ending offset for string
  276.      add    bx, [@@startofs]
  277.      lds    si, [@@stradr]
  278.      add    si, [@@endofs]         ;  and compute end of substring address
  279.      jmp    @@startback
  280.  
  281. @@loopback:
  282.      sub    di, dx             ; reset starting offset of charset string
  283. @@startback:
  284.      cmp    si, bx             ; at beginning of substring?
  285.      jbe    @@strnotfound
  286.      mov    cx, dx             ; reload charset string length
  287.      dec    si             ; decrement source string index
  288.      mov    al, [si]
  289.     repne    scasb
  290.      jne    @@loopback
  291.      pop    ds
  292.      sub    si, [WORD LOW @@stradr] ; compute index of current character
  293.      jmp    @@found
  294.  
  295. @@strnotfound:
  296.      pop    ds
  297. @@charnotfound:
  298.      xor    ax, ax             ; store nil in the
  299.      mov    bx, [@@string]         ;  destination register
  300.      mov    [(REG bx).bpage], al
  301.      mov    [(REG bx).disp], ax
  302.      jmp    @@done
  303.  
  304. @@forwardstr:
  305.      mov    bx, [WORD LOW @@stradr] ; compute ending offset for string
  306.      add    bx, [@@endofs]
  307.      lds    si, [@@stradr]
  308.      add    si, [ss:@@startofs]     ; compute beginning of substring
  309.      jmp    @@startforward
  310.  
  311. @@loopforward:
  312.      sub    di, dx             ; reset starting offset of charset string
  313. @@startforward:
  314.      cmp    si, bx             ; at end of source string?
  315.      jae    @@strnotfound
  316.      mov    cx, dx             ; reload charset string length
  317.      lodsb
  318.     repne    scasb
  319.      jne    @@loopforward
  320.      pop    ds
  321.  
  322.      sub    si, [WORD LOW @@stradr]    ; adjust offset of character found
  323.      dec    si
  324. @@found:
  325.      mov    bx, [@@string]         ; load address of destination register
  326.      call    retnum
  327. @@done:
  328.      xor    ax, ax             ; set completion code for normal return
  329. @@return:
  330.      ret
  331.  
  332. @@error:
  333.      or    cx, cx             ; search forward or backward?
  334.      jnz    @@backerror
  335.      lea    ax, [@@msgfwd]
  336. DATASEG
  337. @@msgfwd DB    "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0
  338. CODESEG
  339.      jmp    @@allerrors
  340.  
  341. @@backerror:
  342.      lea    ax, [@@msgprv]
  343. DATASEG
  344. @@msgprv DB    "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0
  345. CODESEG
  346.  
  347. @@allerrors:
  348.      mov    bx, 4             ; load VM argument count
  349.      call    set_src_error C, ax, bx, [@@string], [@@start], [@@end], [@@charset]
  350.      mov    ax, -1             ; load "invalid operand" flag
  351.      jmp    @@return
  352. ENDP    srch_str
  353.  
  354. ;************************************************************************
  355. ;*                                   al    *
  356. ;* (string-length string)            string-length      d=s1    *
  357. ;*                                    *
  358. ;* Purpose:  Scheme Interpreter support for the "string-lengt" function.*
  359. ;************************************************************************
  360.  
  361. PROC C    st_len USES si, @@string
  362.      mov    bx, [@@string]
  363.      mov    si, [(REG bx).page]
  364.      cmp    [ptype+si], STRTYPE
  365.      jne    @@error
  366.  
  367.     ldpage    es, si
  368.      mov    si, [(REG bx).disp]
  369.     sstrlen    si, <es:si>
  370.      call    retnum
  371.      xor    ax, ax             ; set error code for normal return
  372. @@return:
  373.      ret
  374.  
  375. @@error:
  376.      lea    ax, [@@msg]
  377.      mov    cx, 1             ; indicate one operand
  378.      call    set_src_error C, ax, cx, bx
  379.      mov    ax, -1             ; indicate error return
  380.      jmp    @@return
  381. DATASEG
  382. @@msg    DB    "STRING-LENGTH", 0
  383. CODESEG
  384. ENDP    st_len
  385.  
  386. ;************************************************************************
  387. ;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3)    *
  388. ;************************************************************************
  389. PROC C    str_apnd USES si di, @@end3, @@start3, @@str3, @@str2, @@end1, @@start1, @@str1
  390.      LOCAL     @@len3, @@len2, @@len1, @@offset3, @@offset1
  391.  
  392.      mov    bx, [@@start1]        ; validate string1
  393.      call    getnum
  394.      jnc    @@start1ok
  395. @@linkerror:
  396.      jmp    @@error
  397. @@start1ok:
  398.      add    ax, OFFSET (TYPE STRDEF).buffer
  399.      mov    [@@offset1], ax
  400.      mov    bx, [@@end1]
  401.      call    getnum
  402.      jc    @@linkerror
  403.      add    ax, OFFSET (TYPE STRDEF).buffer
  404.      mov    bx, [@@str1]
  405.      mov    si, [(REG bx).page]
  406.      cmp    [ptype+si], STRTYPE
  407.      jne    @@linkerror
  408.      ldpage    es, si
  409.      mov    si, [(REG bx).disp]
  410.      sstrlen    cx, <es:si>, OVERHEAD
  411.      cmp    ax, cx            ; is ending offset too big ?
  412.      ja    @@linkerror
  413.      sub    ax, [@@offset1]     ; is ending offset too small?
  414.      jb    @@linkerror
  415.      mov    [@@len1], ax
  416.  
  417.      mov    bx, [@@start3]         ; validate string3
  418.      call    getnum
  419.      jc    @@error
  420.      add    ax, OFFSET (TYPE STRDEF).buffer
  421.      mov    [@@offset3], ax
  422.      mov    bx, [@@end3]
  423.      call    getnum
  424.      jc    @@error
  425.      add    ax, OFFSET (TYPE STRDEF).buffer
  426.      mov    bx, [@@str3]
  427.      mov    si, [(REG bx).page]
  428.      cmp    [ptype+si], STRTYPE
  429.      jne    @@error
  430.      ldpage    es, si
  431.      mov    si, [(REG bx).disp]
  432.      sstrlen    cx, <es:si>, OVERHEAD
  433.      cmp    ax, cx            ; is ending offset too big ?
  434.      ja    @@error
  435.      sub    ax, [@@offset3]     ; is ending offset too small?
  436.      jb    @@error
  437.      mov    [@@len3], ax
  438.  
  439.      mov    bx, [@@str2]        ; validate string2, whatever it be
  440.      mov    si, [(REG bx).page]
  441.      cmp    si, NIL_PAGE*2         ; is string2 nil?
  442.      jne    @@notnil
  443.      mov    [@@len2], 0         ; nil has length 0
  444.      jmp    @@common
  445.  
  446. @@error:
  447.      mov    ax, -1            ; signal error
  448.      jmp    @@return
  449.  
  450. @@notnil:
  451.      cmp    si, SPECCHAR*2         ; is string2 a character?
  452.      jne    @@notchar
  453.      mov    [@@len2], 1         ; character has length 1
  454.      jmp    @@common
  455. @@notchar:
  456.      cmp    [ptype+si], STRTYPE    ; is string2 a string?
  457.      jne    @@error
  458.      ldpage    es, si
  459.      mov    si, [(REG bx).disp]
  460.      sstrlen    ax, <es:si>
  461.      mov    [@@len2], ax         ; save string length for further testing
  462.  
  463. @@common:
  464.      mov    ax, [@@len1]         ; compute the length of the new string
  465.      add    ax, [@@len2]
  466.      add    ax, [@@len3]
  467.      cmp    ax, 4000h - OFFSET (TYPE STRDEF).buffer ; greater than max size?
  468.      jge    @@error
  469.      mov    bx, STRTYPE         ; load tag=string
  470.      lea    cx, [tmp_reg]
  471.      call    alloc_block C, cx, bx, ax
  472.      mov    di, [tmp_reg.page]     ; load pointer to newly allocated string
  473.      ldpage    es, di
  474.      mov    di, [tmp_reg.disp]
  475.      lea    di, [(STRDEF di).buffer]
  476.                     ; Move in data from all substrings
  477.      mov    cx, [@@len1]
  478.      mov    bx, [@@str1]
  479.      mov    si, [(REG bx).disp]
  480.      add    si, [@@offset1]
  481.      mov    bx, [(REG bx).page]
  482.  
  483.     push    ds
  484.      ldpage    ds, bx
  485.      rep    movsb                   ; copy string1 into new string
  486.      pop    ds
  487.  
  488.      mov    cx, [@@len2]
  489.      or    cx, cx             ; any characters to move?
  490.      je    @@skipstring2
  491.      mov    bx, [@@str2]
  492.      mov    si, [(REG bx).disp]
  493.      mov    bx, [(REG bx).page]
  494.  
  495.     push    ds
  496.      cmp    bl, SPECCHAR*2         ; is string2 a character?
  497.      jne    @@string2notchar
  498.      mov    si, [@@str2]
  499.      jmp    @@string2copy
  500. @@string2notchar:
  501.      ldpage    ds, bx
  502.      lea    si, [(STRDEF si).buffer]
  503. @@string2copy:
  504.      rep    movsb              ; copy string2 into new string
  505.      pop    ds
  506.  
  507. @@skipstring2:
  508.      mov    cx, [@@len3]
  509.      mov    bx, [@@str3]
  510.      mov    si, [(REG bx).disp]
  511.      add    si, [@@offset3]
  512.      mov    bx, [(REG bx).page]
  513.  
  514.     push    ds
  515.      ldpage    ds, bx
  516.     rep    movsb            ; copy string3 into new string
  517.      pop    ds
  518.  
  519.      mov    di, [@@str1]        ; return pointer to new string
  520.      mov    al, [tmp_reg.bpage]
  521.      mov    [(REG di).bpage], al
  522.      mov    ax, [tmp_reg.disp]
  523.      mov    [(REG di).disp], ax
  524.     xor    ax, ax            ; ax nul = success
  525. @@return:
  526.      ret
  527. ENDP    str_apnd
  528.  
  529. ;************************************************************************
  530. ;*                 Reify(!)-Stack                *
  531. ;*                                    *
  532. ;* Purpose:  To provide the ability to manipulate items on the Scheme    *
  533. ;*        runtime stack from Scheme.                *
  534. ;*                                    *
  535. ;* Description:  The elements of the stack are referenced by providing    *
  536. ;*        the byte offset of the desired element as an index    *
  537. ;*        to the REIFY-STACK or REIFY-STACK! instruction.     An    *
  538. ;*        index of -1 to REIFY-STACK is a request that the current*
  539. ;*        stack frame pointer be returned.            *
  540. ;************************************************************************
  541. PROC C    reif_stk USES si di, @@index, @@value, @@store
  542.      mov    bx, [@@index]
  543.      cmp    [@@store], 0           ; is this a REIFY-STACK operation?
  544.      jne    @@getdata
  545.                     ; index = -1 --> return frame pointer
  546.      cmp    [(REG bx).bpage], SPECFIX*2
  547.      jne    @@getdata
  548.      cmp    [(REG bx).disp], -1
  549.      jne    @@getdata
  550.      mov    si, [frameptr]
  551.      add    si, [base]         ; compute absolute offset
  552.      call    retnum
  553.      jmp    @@done
  554. @@getdata:
  555.      call    getnum
  556.      jc    @@error
  557.      push    ax
  558.      xor    dx, dx
  559.      mov    bx, SIZE POINTER
  560.      div    bx
  561.      pop    ax             ; restore the byte index
  562.      or    dx, dx             ; is it a multiple of POINTERs ?
  563.      jnz    @@error
  564.      mov    dx, [base]         ; current top of stack (topofstack) offset
  565.      add    dx, [topofstack]
  566.      cmp    ax, dx             ; is index larger than topofstack?
  567.      ja    @@error
  568.      cmp    ax, [base]         ; is base < element index?
  569.      jb    @@incontinuation
  570.      sub    ax, [base]         ; compute byte offset in stack buffer
  571.      add    ax, OFFSET s_stack
  572.      mov    si, ax
  573.      push    ds
  574.      pop    es             ; desired element at [es:si]
  575.      jmp    @@doit            ; fetch/store the element
  576.  
  577. @@error:
  578.      cmp    [@@store], 0           ; is this a fetch or store?
  579.      jne    @@storeerror
  580.      lea    ax, [@@msgget]
  581. DATASEG
  582. @@msgget DB    "%REIFY-STACK", 0
  583. CODESEG
  584.      mov    bx, 1             ; 1 operand
  585.      jmp    @@allerrors
  586.  
  587. @@storeerror:
  588.      lea    ax, [@@msgput]
  589. DATASEG
  590. @@msgput DB    "%REIFY-STACK!", 0
  591. CODESEG
  592.      mov    bx, 2             ; 2 operands
  593.      push    [@@value]         ;  and push second reigster operand
  594.  
  595. @@allerrors:
  596.      call    set_src_error C, ax, bx, [@@index]
  597.      mov    ax, -1             ; load an error flag
  598.      jmp    @@ret
  599.  
  600. @@incontinuation:
  601.      mov    bx, [prev_reg.page]     ; make [es:si] point to the previous
  602.      mov    si, [prev_reg.disp]     ;  stack segment continuation object
  603.      ldpage    es, bx
  604. @@loop:
  605.      cmp    ax, [(CONTDEF es:si).base.val]; compare element index:continuation base
  606.      jae    @@found
  607.      mov    bl, [(CONTDEF es:si).stk.page]; load previous stack frame
  608.      mov    si, [(CONTDEF es:si).stk.disp]
  609.      ldpage    es, bx
  610.      jmp    @@loop
  611. @@found:
  612.      sub    ax, [(CONTDEF es:si).base.val]; subtrace off continuation's base
  613.     add    si, ax            ; add entry's byte offset
  614.      lea    si, [(CONTDEF si).data]; adjust for continuation header
  615.  
  616. @@doit:                    ; stack element address at [es:si]
  617.      cmp    [@@store], 0           ; test fetch/store flag
  618.      jne    @@dostore
  619.      mov    bx, [@@index]
  620.      mov    al, [(POINTER es:si).page]; read stack data
  621.      mov    [(REG bx).bpage], al
  622.      mov    ax, [(POINTER es:si).disp]
  623.      mov    [(REG bx).disp], ax
  624.      jmp    @@done
  625. @@dostore:
  626.     mov    bx, [@@value]
  627.     mov    al, [(REG bx).bpage]; write element to stack
  628.     mov    [(POINTER es:si).page], al
  629.     mov    ax, [(REG bx).disp]
  630.     mov    [(POINTER es:si).disp], ax
  631. @@done:
  632.     xor    ax, ax             ; indicate no error encountered
  633. @@ret:
  634.     ret
  635. ENDP    reif_stk
  636.  
  637. ;************************************************************************
  638. ;*                al     al    ah  al       ah        *
  639. ;*    (%SUBSTRING-DISPLAY string start end row-bias window)        *
  640. ;*                                    *
  641. ;* Purpose:  Special support for displaying strings to the CRT for    *
  642. ;*        applications such as text editors.            *
  643. ;************************************************************************
  644. ; Local storge :
  645. ;        sd_buff        string buffer
  646. ;        sd_char         "saved" character
  647. ;        sd_start     substring's starting offset
  648. ;        sd_end        substring's ending offset
  649. ;        sd_bias        row bias
  650. ;        sd_cline     cursor line number
  651. ;        sd_ccol        cursor column number
  652. ;        sd_nline     number of lines in the window
  653. ;        sd_ncols     number of columns in the window
  654. ;        sd_ullin     upper left corner line number
  655. ;        sd_ulcol     upper left corner column number
  656. ;        sd_text        text attributes for window
  657. ;        sd_cursv     cursor coordinate save area
  658. ;        sd_last        last write flag
  659. ;        sd_linum     line number
  660. ; Warning: the following two (2) items are order dependent
  661. ;        sd_wn_si     pointer to window object, part 1
  662. ;        sd_wn_es     pointer to window object, part 2
  663.  
  664. SCREENSIZE = 132 shl 1            ; does anybody have more than 132 cols ?
  665.  
  666. PROC C    str_disp USES si di, @@winreg, @@disp, @@end, @@start, @@string
  667.     LOCAL    @@winadr:DWORD, @@endofs, @@startofs
  668.     LOCAL    $$bias, $$char:BYTE, $$buffer:BYTE:SCREENSIZE
  669.     LOCAL    $$linenum:BYTE, $$lastwrite, $$cursorsave, $$textattrib
  670.     LOCAL    $$ulcol, $$ullin, $$ncols, $$nline, $$ccol, $$cline
  671.  
  672.     mov    [$$lastwrite], 0     ; initialize "last write?" flag
  673.     mov    [$$linenum], 0         ; line number
  674.     mov    bx, [@@start]
  675.     call    getnum         ; obtain starting offset
  676.     jc    @@toerror
  677.     add    ax, OFFSET (TYPE STRDEF).buffer
  678.     mov    [@@startofs], ax     ; save starting offset
  679.     mov    bx, [@@end]
  680.     call    getnum         ; obtain ending offset
  681.     jc    @@toerror
  682.     add    ax, OFFSET (TYPE STRDEF).buffer
  683.     cmp    ax, [@@startofs]     ; is ending offset greater than starting?
  684.     jb    @@toerror
  685.     mov    [@@endofs], ax         ; save ending offset
  686.  
  687.     mov    bx, [@@disp]
  688.     cmp    [(REG bx).bpage], SPECFIX*2
  689.     je    @@jmpnoerror
  690. @@toerror:
  691.     jmp    @@error
  692. @@jmpnoerror:
  693.     mov    ax, [(REG bx).disp]
  694.     mov    [$$bias], ax
  695.     call    get_port C, [@@winreg], [@@one]
  696.     or    ax, ax             ; valid port operand?
  697.     jne    @@error
  698.     mov    si, [tmp_reg.page]     ; load a pointer to the port object
  699.     ldpage    es, si
  700.     mov    si, [tmp_reg.disp]
  701.     mov    ax, [(PORTDEF es:si).pflags]
  702.     test    ax, PORT_TYPE         ; is this port a window?
  703.     jnz    @@error
  704.     test    ax, WRITE_MODE         ; window open for output?
  705.     jnz    @@open
  706.     jmp    @@return              ; if closed, ignore I/O request
  707. @@open:
  708.     mov    ax, [(PORTDEF es:si).curline]
  709.     mov    [$$cline], ax
  710.     mov    ax, [(PORTDEF es:si).curcol]
  711.     mov    [$$ccol], ax
  712.     mov    ax, [(PORTDEF es:si).nlines]
  713.     mov    [$$nline], ax
  714.     mov    ax, [(PORTDEF es:si).ncols]
  715.     mov    [$$ncols], ax
  716.     mov    ax, [(PORTDEF es:si).ulline]
  717.     mov    [$$ullin], ax
  718.     mov    ax, [(PORTDEF es:si).ulcol]
  719.     mov    [$$ulcol], ax
  720.     mov    ax, [(PORTDEF es:si).text]
  721.     mov    [$$textattrib], ax
  722.     mov    [WORD HIGH @@winadr], es; save pointer to window object
  723.     mov    [WORD LOW @@winadr], si
  724.     jmp    @@more
  725.  
  726. @@error:
  727.     restore <si>             ; load address of next instruction and
  728.     sub    si, 6             ;  adjust for 5 operands + opcode
  729.     lea    ax, [@@msg]
  730.     push    es            ; saves es over C call
  731.     call    disassemble C, ax, si
  732.     call    set_numeric_error C, [@@one], [@@opnd], [tmp_adr]
  733.     pop    es
  734.     mov    ax, -1            ; signal error
  735.     ret
  736. DATASEG
  737. @@msg    DB    "%SUBSTRING-DISPLAY", 0
  738. @@one    DW    1             ; a constant "one" (1)
  739. @@opnd    DW    INVALID_OPERAND_ERROR     ; numeric error code
  740. CODESEG
  741.  
  742. @@more:                    ; validate the string operand
  743.     mov    bx, [@@string]
  744.     mov    si, [(REG bx).page]
  745.     cmp    [ptype+si], STRTYPE
  746.     jne    @@error
  747.     ldpage    es, si
  748.     mov    si, [(REG bx).disp]
  749.     sstrlen    ax, <es:si>, OVERHEAD
  750.     cmp    ax, [@@endofs]         ; is ending offset too big?
  751.     jb    @@error
  752.     mov    dx, [@@endofs]        ; Note:  [es:si] points to the source string
  753.     add    dx, si             ; compute ending address
  754.     add    si, [@@startofs]
  755.  
  756.     mov    cx, [$$ccol]        ; translate the string into the local buffer
  757.     mov    bx, [$$ncols]
  758.     lea    di, [$$buffer]
  759.     push    ds
  760.     push    ds es            ; swap ds and es
  761.     pop    ds es
  762.  
  763. ; Warning: ds does not point to the the data segment in the code which follows
  764.  
  765. ;     Register usage:  [es:di] - next character in output buffer
  766. ;               [es:si] - next character in source string
  767. ;               bx - number of columns in window
  768. ;               cx - current column (cursor position) relative to window
  769. ;               dx - end of source string address
  770. @@next:
  771.     cmp    si, dx             ; end of input string?
  772.     jae    @@final
  773.     lodsb
  774.     cmp    al, CTRL_Z         ; possible control character?
  775.     ja    @@normal
  776.     cmp    al, TAB
  777.     jne    @@control
  778.  
  779.     mov    al, ' '            ; TAB character-- output a series of blanks
  780.     mov    ah, cl             ; copy cursor position
  781.     sub    ah, [$$linenum]        ;  and adjust for line number
  782. @@tabloop:
  783.     stosb                ; store a blank to the output buffer
  784.     inc    cx             ; increment the current column number
  785.     inc    ah
  786.     test    ah, 07h         ; is next column a multiple of eight?
  787.     jnz    @@tabloop
  788.     jmp    @@test
  789. @@control:
  790.     mov    ah, al             ; save control character
  791.     mov    al, '^'           ; load a "^" character and output to buffer
  792.     stosb
  793.     inc    cx
  794.     mov    al, ah             ; copy control character to al and
  795.     add    al, '@'            ; output the corresponding ASCII char
  796. @@normal:                ; non- control character-- just copy to output buffer
  797.     stosb
  798.     inc    cx             ; increment the current column number
  799. @@test:
  800.     cmp    cx, bx             ; line full?
  801.     jb    @@next
  802.  
  803.     call    flush            ; Full line buffered-- display it on the screen
  804.     mov    ax, [$$cline]
  805.     cmp    ax, [$$nline]         ; are we at the end of the screen?
  806.     jl    @@next
  807.                     ; Window full-- set cursor position to last line + 1, column 0
  808.     les    si, [@@winadr]
  809.     mov    [(PORTDEF es:si).curcol], 0
  810.     mov    cx, [$$cline]
  811.     mov    [(PORTDEF es:si).curline], cx
  812.     jmp    @@done
  813.  
  814. @@final:
  815.     push    es             ; end of string-- output final line
  816.     les    si, [@@winadr]
  817.     mov    ax, cx             ; save current column
  818.     mov    [(PORTDEF es:si).curcol], cx
  819.     mov    cx, [$$cline]
  820.     mov    [(PORTDEF es:si).curline], cx
  821.     pop    es
  822.     mov    cx, SCREENSIZE - 1    ; load buffer length
  823.     sub    cx, ax             ; subtract number of columns in buffer
  824.     mov    al, ' '
  825.     rep    stosb
  826.     mov    [$$lastwrite], 1    ; indicate last line
  827.     call    flush             ; display to screen
  828. @@done:
  829.     pop    ds
  830.  
  831. @@return:                     ; Operation complete-- return to Scheme interpreter
  832.     xor    ax, ax            ; clear ax = success
  833.     ret
  834.  
  835. ;************************************************************************
  836. ;*          Local Support:  Flush Output Buffer to Screen        *
  837. ;************************************************************************
  838. PROC NOLANGUAGE    flush near
  839.     push    ds si di cx dx         ; save valuable registers
  840.     push    es            ; Make ds register point to data segment
  841.     pop    ds
  842.  
  843.     inc    [$$bias]         ; Test for negative bias
  844.     jg    @@nobias
  845.     jmp    @@skip             ; if negative, don't display current line
  846.  
  847. @@nobias:                ; Position the cursor in the current column position
  848.     mov    dh, [BYTE $$cline]     ; load the current cursor position
  849.     mov    dl, [BYTE $$ccol]
  850.     add    dh, [BYTE $$ullin]
  851.     add    dl, [BYTE $$ulcol]
  852.     mov    [$$cursorsave], dx
  853.     xor    bh, bh             ; page 0 for text-mode
  854.     mov    ah, 02h
  855.     int    IBM_CRT         ; put cursor at current position
  856.     mov    cx, [$$ncols]
  857.     sub    cx, [$$ccol]
  858.     lea    bx, [$$buffer]        ; Replace the "last" character in line with an exclamation mark
  859.     cmp    [$$lastwrite], 0
  860.     jnz    @@lastline         ; if last line, leave character alone (jump)
  861.     mov    si, cx             ; copy character count
  862.     mov    al, '!'
  863.  
  864.     xchg    al, [bx+si-1]
  865.     mov    [$$char], al         ; save character to later viewing
  866. @@lastline:
  867.     mov    di, bx            ; load buffer offset into di
  868.     mov    dx, [$$cursorsave]     ; reverse row/column coordinates
  869.     push    cx             ; save the character counter
  870.     jmp    @@inmiddle
  871. @@loop:
  872.     push    cx             ; save the character counter
  873.     mov    dx, [$$cursorsave]     ; load the previous cursor coordinates,
  874.     inc    dl             ; increment the column number
  875.     mov    [$$cursorsave], dx
  876.     xor    bh, bh
  877.     mov    ah, 02h
  878.     push    di
  879.     int    IBM_CRT
  880.     pop    di
  881. @@inmiddle:
  882.     mov    ah, 09h         ; Load "write char w/ attributes" code
  883.     mov    al, [BYTE di]
  884.     mov    bl, [BYTE $$textattrib] ; load attribute bits
  885.     xor    bh, bh             ; page # for alpha mode
  886.     mov    cx, 1            ; test to see if we buy anything by using a repeat count
  887.     pop    dx             ; restore character count
  888. @@more:
  889.     cmp    dx, 1             ; more characters to display?
  890.     jle    @@bottom         ; if no more characters, jump
  891.     cmp    al, [BYTE di+1]
  892.     jne    @@bottom         ; if not same character, jump
  893.     inc    cx
  894.     inc    di
  895.     inc    [BYTE $$cursorsave]
  896.     dec    dx             ; decrement the character count
  897.     jmp    @@more
  898. @@bottom:
  899.     push    dx di
  900.     int    IBM_CRT         ; write character with attributes
  901.     pop    di cx
  902.     inc    di             ; increment buffer pointer
  903.     loop    @@loop
  904.  
  905. @@back:                    ; Restore last character in line to its rightful value
  906.     mov    si, [$$ncols]
  907.     sub    si, [$$ccol]
  908.     mov    al, [$$char]
  909.     lea    bx, [$$buffer]
  910.     mov    [bx+si-1], al
  911.     inc    [$$cline]        ; Shift buffer to remove the line just displayed
  912. @@skip:
  913.     mov    si, [$$ncols]         ; compute number of characters just output
  914.     sub    si, [$$ccol]         ;  (unless bias < 0, in which case we just
  915.     dec    si             ;   branched here)
  916.     push    si
  917.     mov    cx, 10             ; make up a character count for move
  918.     lea    di, [$$buffer]
  919.     add    si, di
  920.     rep    movsb             ; shift any characters left over
  921.     mov    bx, [$$ccol]        ; save the current column for adjust
  922.     mov    [$$ccol], 0
  923.     inc    [$$linenum]         ; increment formatting line number
  924.  
  925.                     ; Reset Active Registers to reflect shifted buffer
  926.     pop    ax dx cx di si         ; restore char count & control registers
  927.     sub    di, ax             ; adjust buffer index
  928.     sub    cx, ax             ; adjust current column
  929.     sub    cx, bx
  930.     mov    bx, [$$ncols]         ; reload line length
  931.     pop    ds
  932.     ret
  933. ENDP    flush
  934.  
  935. ENDP    str_disp
  936.  
  937. ;************************************************************************
  938. ;* Local Support:  Fetch and Validate Integer Argument            *
  939. ;*                                    *
  940. ;* Input Parameters:  bx - address of register containing the integer    *
  941. ;*              argument                    *
  942. ;*                                    *
  943. ;* Output Parameters:  If CARRY off, normal return:            *
  944. ;*              ax - the 16 bit positive integer value    *
  945. ;*               If CARRY on, error:                *
  946. ;*              ax - the error condition; 0=operand not an    *
  947. ;*                integer; 1=integer operand was negative    *
  948. ;*                or larger than 16 bits.            *
  949. ;************************************************************************
  950. PROC    getnum    near
  951.     cmp    [(REG bx).bpage], SPECFIX*2
  952.     jne    @@bignum
  953.     mov    ax, [(REG bx).disp]
  954.     or    ax, ax            ; negative?
  955.     js    @@badvalue
  956.     clc
  957.     ret
  958. @@bignum:
  959.     mov    si, [(REG bx).page]
  960.     cmp    [ptype+si], BIGTYPE    ; is argument a bignum?
  961.     jne    @@type
  962.     ldpage    es, si
  963.     mov    si, [(REG bx).disp]
  964.     cmp    [(BIGDEF es:si).data.sign], 0
  965.     jne    @@badvalue
  966.     cmp    [(BIGDEF es:si).data.len], OFFSET (TYPE BIGDEF).data.lsw + (TYPE WORD) + 1
  967.     jne    @@badvalue
  968.     mov    ax, [(BIGDEF es:si).data.lsw]; load 16 bit value of bignum
  969.     clc
  970.     ret
  971. @@type:
  972.     mov    ax, 0             ; indicate operand wrong type
  973.     stc
  974.     ret
  975. @@badvalue:
  976.     mov    ax, 1
  977.     stc
  978.     ret
  979. ENDP    getnum
  980.  
  981. ;************************************************************************
  982. ;* Local Support:  Return a 16 bit positive integer value        *
  983. ;*                                    *
  984. ;* Input Parameters:  bx - address of destination register        *
  985. ;*              si - 16 bit unsigned integer value to be returned *
  986. ;*                                    *
  987. ;* Output Parameters:  The Scheme representation of the 16 bit unsigned    *
  988. ;*            value is placed into the destination register.    *
  989. ;************************************************************************
  990. PROC    retnum    near
  991.     cmp    si, 07fffh         ; can result be represented as a fixnum?
  992.     ja    @@makebig
  993.     mov    [(REG bx).bpage], SPECFIX*2 ; return a fixnum result
  994.     mov    [(REG bx).disp], si
  995.     ret
  996. @@makebig:
  997.     push    si
  998.     push    bx
  999.  
  1000.     mov    cx, 1+2            ; load size of bignum desired
  1001.     mov    ax, BIGTYPE
  1002.     call    alloc_block C, bx, ax, cx
  1003.  
  1004.     pop    bx             ; restore destination reg
  1005.     mov    si, [(REG bx).page]
  1006.     ldpage    es, si
  1007.     mov    si, [(REG bx).disp]
  1008.     mov    [(BIGDEF es:si).data.sign], 0
  1009.     pop    [(BIGDEF es:si).data.lsw] ; store value into the bignum
  1010.     ret
  1011. ENDP    retnum
  1012.  
  1013.     END
  1014.